perm filename DDSAI.SAI[S,HE] blob sn#478504 filedate 1982-05-21 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00009 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	entry getddf,putddf,DDSTOR,DDLOAD,MAPMON,MAPGRY,DDFONT,GETMIT,PUTMIT,TEXTD,XGPQUE,
C00005 00003	internal BOOLEAN PROCEDURE GETDDF(STRING FILNAME)
C00006 00004	INTERNAL BOOLEAN PROCEDURE PUTMIT(STRING FILNAME)
C00009 00005	INTERNAL BOOLEAN PROCEDURE MAPMON(REAL GAMMA   comment FOR OFTEN NEEDED F's
C00011 00006	text routines
C00017 00007	INTERNAL PROCEDURE FNTSEL(INTEGER F STRING FNTNAM)  comment select a font #F
C00022 00008	INTERNAL BOOLEAN PROCEDURE DDFONT(REAL X1,Y1,X2,Y2
C00030 00009	INTERNAL BOOLEAN PROCEDURE XGPQUE(INTEGER SIZE)
C00032 ENDMK
C⊗;
entry getddf,putddf,DDSTOR,DDLOAD,MAPMON,MAPGRY,DDFONT,GETMIT,PUTMIT,TEXTD,XGPQUE,
      TXTPOS,TEXT,FNTSEL,FNTPOS,FNTEXT,FNTDOT,FNTLIN,FNTREC,FNTELL,FNTPOL;
BEGIN
REQUIRE "FILHDR.SAI[VIS,HPM]" SOURCE_FILE;
EXTERNAL BOOLEAN procedure mapset(reference real procedure f;integer reset);
EXTERNAL PROCEDURE DDPAK(INTEGER SCANLINE; REFERENCE INTEGER BUF; INTEGER XLO,XHI);
EXTERNAL PROCEDURE SCREEM(REFERENCE REAL X1,Y1,X2,Y2);
EXTERNAL PROCEDURE SCREEN(REAL X1,Y1,X2,Y2);
EXTERNAL PROCEDURE ELLIPS(REAL X1,Y1,X2,Y2);
EXTERNAL PROCEDURE RECTAN(REAL X1,Y1,X2,Y2);
EXTERNAL PROCEDURE POLYGO(INTEGER N; REFERENCE REAL X,Y);
EXTERNAL PROCEDURE LINE(REAL X1,Y1,X2,Y2; INTEGER THK(0));
EXTERNAL PROCEDURE DOT(REAL X1,Y1; INTEGER THK(0));
EXTERNAL INTEGER DBUF;
DEFINE DDSIZ='22*'740+'52;

INTERNAL PROCEDURE DDSTOR(REFERENCE INTEGER DDARRAY);
   ARRBLT(DDARRAY,DBUF,DDSIZ);

INTERNAL PROCEDURE DDLOAD(REFERENCE INTEGER DDARRAY);
   ARRBLT(DBUF,DDARRAY,DDSIZ);
internal BOOLEAN PROCEDURE GETDDF(STRING FILNAME);
   BEGIN
   INTEGER FOO,FLAG,CHAN;
   CHAN←GETCHAN;
   PRSFIL(FILNAME);
   OPEN(CHAN,DEVPRS,'17,7,0,FOO,FOO,FOO);
   LOOKUP(CHAN,FILPRS,FLAG);
   IF ¬FLAG THEN ARRYIN(CHAN,DBUF,DDSIZ);
   RELEASE(CHAN);
   RETURN(¬FLAG);
   END;

internal BOOLEAN PROCEDURE PUTDDF(STRING FILNAME);
   BEGIN
   INTEGER FOO,FLAG,CHAN;
   CHAN←GETCHAN;
   PRSFIL(FILNAME);
   OPEN(CHAN,DEVPRS,'17,0,19,FOO,FOO,FOO);
   ENTER(CHAN,FILPRS,FLAG);
   IF ¬FLAG THEN ARRYOUT(CHAN,DBUF,DDSIZ);
   RELEASE(CHAN);
   RETURN(¬FLAG);
   END;
INTERNAL BOOLEAN PROCEDURE PUTMIT(STRING FILNAME);
   BEGIN
   EXTERNAL INTEGER SLINE;
   EXTERNAL INTEGER DBUF;
   INTEGER ARRAY LIN[0:15];
   INTEGER FOO,FLAG,CHAN,I,J;
   CHAN←GETCHAN;
   PRSFIL(FILNAME);
   OPEN(CHAN,DEVPRS,'10,0,5,FOO,FOO,FOO);
   ENTER(CHAN,FILPRS,FLAG);
   IF ¬FLAG THEN
      BEGIN
      FOR I←1 STEP 1 UNTIL 454 DO
         BEGIN
         FOR J←0 STEP 1 UNTIL 15 DO
            LIN[J]←MEMORY[LOCATION(DBUF)+MEMORY[LOCATION(SLINE)+I+13]+J] LAND '777777777760;
         ARRYOUT(CHAN,LIN[0],16);
         END;
      END;
   RELEASE(CHAN);
   RETURN(¬FLAG);
   END;

INTERNAL BOOLEAN PROCEDURE GETMIT(STRING FILNAME);
   BEGIN
   EXTERNAL INTEGER SLINE;
   EXTERNAL INTEGER DBUF;
   INTEGER ARRAY LIN[0:15];
   INTEGER FOO,FLAG,CHAN,I,J;
   CHAN←GETCHAN;
   PRSFIL(FILNAME);
   OPEN(CHAN,DEVPRS,'10,5,0,FOO,FOO,FOO);
   LOOKUP(CHAN,FILPRS,FLAG);
   IF ¬FLAG THEN
      BEGIN
      FOR I←1 STEP 1 UNTIL 454 DO
         BEGIN
         ARRYIN(CHAN,LIN[0],16);
         FOR J←0 STEP 1 UNTIL 15 DO
            MEMORY[LOCATION(DBUF)+MEMORY[LOCATION(SLINE)+I+13]+J]←
            MEMORY[LOCATION(DBUF)+MEMORY[LOCATION(SLINE)+I+13]+J] LOR (LIN[J] LAND '777777777760);
         END;
      END;
   RELEASE(CHAN);
   RETURN(¬FLAG);
   END;
INTERNAL BOOLEAN PROCEDURE MAPMON(REAL GAMMA;   comment FOR OFTEN NEEDED F's;
				  INTEGER RESET);
   BEGIN					COMMENT GAMMA=0 AND .4 ARE GOOD;
   REAL PROCEDURE F(REAL X);
      BEGIN
      REAL G;
      IF GAMMA<0 THEN X←1-X; G←ABS(GAMMA);
      RETURN(IF G≠0 THEN X↑G ELSE LOG(25*x+1)/log(26));
      END;

   RETURN(MAPSET(F,RESET));
   END;


INTERNAL BOOLEAN PROCEDURE MAPGRY(REAL GAMMA;   comment FOR OFTEN NEEDED F's;
			       INTEGER NBITM;
                               INTEGER RESET);  COMMENT for Gray coded displays;
   BEGIN                                        COMMENT GAMMA=0 AND .4 ARE GOOD;
   INTEGER NBITS;
   EXTERNAL INTEGER PROCEDURE SYNMAP(INTEGER ORD, RESET(FALSE));

   REAL PROCEDURE F(REAL X);
      BEGIN
      REAL G; INTEGER IX,NX;
      IX←X*2↑NBITS;
 	 NX←0; WHILE IX>0 DO BEGIN NX←NX XOR IX; IX←IX LSH -1; END;
      X←NX/2↑NBITS;
      IF GAMMA<0 THEN X←1-X; G←ABS(GAMMA);
      RETURN(IF G≠0 THEN X↑G ELSE LOG(25*x+1)/log(26));
      END;

   NBITS←0; WHILE SYNMAP(NBITS)>0 DO NBITS←NBITS+1;
   NBITS←NBITS MIN NBITM;
   RETURN(MAPSET(F,RESET));
   END;
comment text routines;
OWN REAL XLO,YLO,XLIM,YLIM,XS,YS,DXS,DYS, FXP,FYP,FXS,FYS,FDXS,FDYS;

INTERNAL PROCEDURE TXTPOS(REAL XPOS,YPOS,XSZ,YSZ,DXSZ(0.0),DYSZ(0.0));
   BEGIN
   XLIM←XPOS; XLO←XPOS; XS←XSZ; DXS←DXSZ;
   YLIM←YPOS; YLO←YPOS; YS←YSZ; DYS←DYSZ;
   END;

INTERNAL PROCEDURE TEXT(STRING TXT);
   BEGIN
   EXTERNAL INTEGER LETAB;

   INTEGER I,J,IL,JL,LETT,PNT;

   WHILE LENGTH(TXT)>0 DO
      BEGIN
      LETT←LOP(TXT);
      IF LETT='15 THEN
         BEGIN REAL X,Y; X←XLO; Y←YLO;
         XLO←XLIM+DXS*(XS*(Y-YLIM)-DYS*(X-XLIM))/(XS*YS-DXS*DYS);
         YLO←YLIM+YS*(XS*(Y-YLIM)-DYS*(X-XLIM))/(XS*YS-DXS*DYS); END ELSE
      IF LETT='12 THEN BEGIN XLO←XLO-DXS; YLO←YLO-YS; END ELSE
      IF LETT='11 THEN BEGIN XLO←XLO+4*XS; YLO←YLO+4*DYS; END ELSE
      IF LETT='177 THEN BEGIN XLO←XLO-XS; YLO←YLO-DYS; END ELSE
      IF LETT=0 THEN ELSE
         BEGIN
         PNT←POINT(3,MEMORY[LOCATION(LETAB)+3*LETT],-1);
         J←ILDB(PNT); I←ILDB(PNT);
         WHILE ¬(J=7 ∧ I=7) DO
            BEGIN
            IL←I; JL←J;
            J←ILDB(PNT); I←ILDB(PNT);
	    IF J≠7 THEN
               BEGIN
               IF IL=7 THEN IL←-3; IF I=7 THEN I←-3;
	       LINE(XLO+(JL/6)*XS+((IL)/10)*DXS,YLO+((IL)/10)*YS+(JL/6)*DYS,
	             XLO+(J/6)*XS+((I)/10)*DXS,YLO+((I)/10)*YS+(J/6)*DYS);
               END
            ELSE IF I=0 THEN BEGIN J←ILDB(PNT); I←ILDB(PNT); END;
            END;
         XLO←XLO+XS;
         YLO←YLO+DYS;
         END;
      END;
   END;

INTERNAL PROCEDURE TEXTD(STRING TXT);
   BEGIN
   EXTERNAL INTEGER DOTLET;
   INTEGER I,J,LETT,PNT; REAL XL,YL,XH,YH,RX,RY;

   SCREEM(XL,YL,XH,YH);
   RX←(XS/6)↑2+(DXS/10)↑2;
   RY←(YS/10)↑2+((DYS)/6)↑2;
   IF RX < 4*((XH-XL)/512)↑2 THEN RX←0;
   IF RY < 4*((YH-YL)/481)↑2 THEN RY←0;

   WHILE LENGTH(TXT)>0 DO
      BEGIN
      LETT←LOP(TXT);
      IF LETT='15 THEN
         BEGIN REAL X,Y; X←XLO; Y←YLO;
         XLO←XLIM+DXS*(XS*(Y-YLIM)-DYS*(X-XLIM))/(XS*YS-DXS*DYS);
         YLO←YLIM+YS*(XS*(Y-YLIM)-DYS*(X-XLIM))/(XS*YS-DXS*DYS); END ELSE
      IF LETT='12 THEN BEGIN XLO←XLO-DXS; YLO←YLO-YS; END ELSE
      IF LETT='11 THEN BEGIN XLO←XLO+4*XS; YLO←YLO+4*DYS; END ELSE
      IF LETT='177 THEN BEGIN XLO←XLO-XS; YLO←YLO-DYS; END ELSE
      IF LETT=0 THEN ELSE
         BEGIN
         PNT←POINT(1,MEMORY[LOCATION(DOTLET)+2*LETT],-1);
         IF RX=0∧RY=0 THEN
            BEGIN
	    FOR I←0 STEP 1 UNTIL 9 DO
	    FOR J←0 STEP 1 UNTIL 5 DO
	    IF ILDB(PNT) THEN
            DOT(XLO+((J+1.0001)/6)*XS+((7.9999-I)/10)*DXS,
                YLO+((7.9999-I)/10)*YS+((J+1.0001)/6)*DYS);
            END
         ELSE
            BEGIN
	    FOR I←0 STEP 1 UNTIL 9 DO
	    FOR J←0 STEP 1 UNTIL 5 DO
	    IF ILDB(PNT) THEN
               BEGIN
	       REAL ARRAY X,Y[1:4];
	       X[1]←XLO+((J+.5)/6)*XS+((7.5-I)/10)*DXS;
	       Y[1]←YLO+((7.5-I)/10)*YS+((J+.5)/6)*DYS;
	       X[2]←XLO+((J+1.5)/6)*XS+((7.5-I)/10)*DXS;
	       Y[2]←YLO+((7.5-I)/10)*YS+((J+1.5)/6)*DYS;
	       X[3]←XLO+((J+1.5)/6)*XS+((8.5-I)/10)*DXS;
	       Y[3]←YLO+((8.5-I)/10)*YS+((J+1.5)/6)*DYS;
	       X[4]←XLO+((J+.5)/6)*XS+((8.5-I)/10)*DXS;
	       Y[4]←YLO+((8.5-I)/10)*YS+((J+.5)/6)*DYS;
	       POLYGO(4,X[1],Y[1]);
               END;
            END;
	 XLO←XLO+XS;
	 YLO←YLO+DYS;
         END;
      END;

   END;
INTERNAL PROCEDURE FNTSEL(INTEGER F; STRING FNTNAM);  comment select a font #F;
   BEGIN
   comment nothing to do;
   END;

INTERNAL PROCEDURE FNTPOS(REAL XPOS,YPOS,XSZ(1.0),YSZ(1.0),DXSZ(0.0),DYSZ(0.0));
    BEGIN
    FXP←XPOS; FYP←YPOS;
    FXS←XSZ; FYS←YSZ;
    FDXS←DXSZ; FDYS←DYSZ;
    END;

INTERNAL PROCEDURE FNTEXT(REAL XP,YP; INTEGER FNT; STRING TXT);
    BEGIN
    REAL XL,YL,XH,YH;
    SCREEM(XL,YL,XH,YH);
    TXTPOS(FXP+(FXS*XP+FDXS*YP)*(XH-XL)*0.5/512,
	   FYP+(FYS*YP+FDYS*XP)*(YH-YL)*0.5/480,
	   FXS*6*(XH-XL)/512,FYS*10*(YH-YL)/480,
	   FDXS*10*(XH-XL)/512,FDYS*6*(YH-YL)/480);
    TEXTD(TXT);
    END;

INTERNAL PROCEDURE FNTLIN(REAL X1,Y1,X2,Y2; INTEGER TH(0));
    BEGIN
    REAL ARRAY X,Y[1:2]; REAL XL,YL,XH,YH,DX,DY; INTEGER I;
    X[1]←X1; Y[1]←Y1; X[2]←X2; Y[2]←Y2;
    SCREEM(XL,YL,XH,YH);
    FOR I←1 STEP 1 UNTIL 2 DO
       BEGIN
       DX←FXP+(FXS*X[I]+FDXS*Y[I])*(XH-XL)*0.5/512;
       DY←FYP+(FYS*Y[I]+FDYS*X[I])*(YH-YL)*0.5/480;
       X[I]←DX; Y[I]←DY;
       END;
    LINE(X[1],Y[1],X[2],Y[2],TH);
    END;

INTERNAL PROCEDURE FNTDOT(REAL X,Y; INTEGER TH(0));
    BEGIN
    REAL XL,YL,XH,YH,XP,YP; INTEGER I,TH;
    SCREEM(XL,YL,XH,YH);
    XP←FXP+(FXS*X+FDXS*Y)*(XH-XL)*0.5/512;
    YP←FYP+(FYS*Y+FDYS*X)*(YH-YL)*0.5/480;
    DOT(X,Y,TH);
    END;

INTERNAL PROCEDURE FNTREC(REAL XL,YL,XH,YH);
    BEGIN
    REAL ARRAY X,Y[1:2]; REAL DX,DY; INTEGER I;
    X[1]←XL; Y[1]←YL;
    X[2]←XH; Y[2]←YH;
    SCREEM(XL,YL,XH,YH);
    FOR I←1 STEP 1 UNTIL 2 DO
       BEGIN
       DX←FXP+(FXS*X[I]+FDXS*Y[I])*(XH-XL)*0.5/512;
       DY←FYP+(FYS*Y[I]+FDYS*X[I])*(YH-YL)*0.5/480;
       X[I]←DX; Y[I]←DY;
       END;
    RECTAN(X[1],Y[1],X[2],Y[2]);
    END;

INTERNAL PROCEDURE FNTELL(REAL XL,YL,XH,YH);
    BEGIN
    REAL ARRAY X,Y[1:2]; REAL DX,DY; INTEGER I;
    X[1]←XL; Y[1]←YL;
    X[2]←XH; Y[2]←YH;
    SCREEM(XL,YL,XH,YH);
    FOR I←1 STEP 1 UNTIL 2 DO
       BEGIN
       DX←FXP+(FXS*X[I]+FDXS*Y[I])*(XH-XL)*0.5/512;
       DY←FYP+(FYS*Y[I]+FDYS*X[I])*(YH-YL)*0.5/480;
       X[I]←DX; Y[I]←DY;
       END;
    ELLIPS(X[1],Y[1],X[2],Y[2]);
    END;

INTERNAL PROCEDURE FNTPOL(INTEGER N; REFERENCE REAL X,Y);
    BEGIN
    REAL ARRAY X,Y[1:N]; REAL XL,YL,XH,YH,DX,DY; INTEGER I;
    SCREEM(XL,YL,XH,YH);
    FOR I←1 STEP 1 UNTIL N DO
       BEGIN
       X[I]←MEMORY[LOCATION(X)+I-1,REAL]; Y[I]←MEMORY[LOCATION(Y)+I-1,REAL];
       DX←FXP+(FXS*X[I]+FDXS*Y[I])*(XH-XL)*0.5/512;
       DY←FYP+(FYS*Y[I]+FDYS*X[I])*(YH-YL)*0.5/480;
       X[I]←DX; Y[I]←DY;
       END;
    POLYGO(N,X[1],Y[1]);
    END;
INTERNAL BOOLEAN PROCEDURE DDFONT(REAL X1,Y1,X2,Y2;
			STRING FILNAME; INTEGER CODE("A");
                        REAL FBASEL(0),FLKERN(0),FRKERN(0));
   BEGIN
   INTEGER FOO,FLAG,CHAN,ICHAN,I,J,K,L,IFLAG,XA,XB,YA,YB,NW,MAXBOT,MAXTOP;
   INTEGER ARRAY BUF[0:'200],LIN[0:25];
   INTEGER BASEL,LKERN,RKERN;
   ICHAN←GETCHAN;
   PRSFIL(FILNAME);
   OPEN(ICHAN,DEVPRS,'10,19,0,FOO,FOO,FOO);
   LOOKUP(ICHAN,FILPRS,IFLAG);
   IF IFLAG THEN RELEASE(ICHAN);
   CHAN←GETCHAN;
   OPEN(CHAN,DEVPRS,'10,0,19,FOO,FOO,FOO);
   ENTER(CHAN,FILPRS,FLAG);
   IF ¬FLAG THEN
      BEGIN
      EXTERNAL REAL YH,YSC,XL,XSC;

      LKERN←FLKERN*XSC+0.5;
      RKERN←FRKERN*XSC+0.5;
      BASEL←-FBASEL*YSC+0.5;

      XA←(X1-XL)*XSC;
      XB←(X2-XL)*XSC;  IF XA>XB THEN XA↔XB;
      YA←(Y1-YH)*YSC;
      YB←(Y2-YH)*YSC;  IF YA>YB THEN YA↔YB;

      XA←XA MAX 0; XB←XB MIN 511;
      YA←YA MAX 0; YB←YB MIN 480;
      IF XA>XB ∨ YA>YB THEN RETURN(FALSE);
      XB←XB MIN (XA+510);

      NW←(XB-XA+1+35)%36;

      IF IFLAG THEN
         BEGIN  comment the file doesn't already exist;
         ARRCLR(BUF);
         BUF[CODE]←((XB-XA+1-LKERN-RKERN) LSH 18) LOR '400;
         ARRYOUT(CHAN,BUF[0],'200);
         ARRCLR(BUF);
         MAXBOT←(-BASEL) MAX 0; MAXTOP←YB-YA+1+(BASEL MAX 0);
         BUF[1]←MAXTOP+MAXBOT;
         BUF[2]←XB-XA+1;
         BUF[3]←(YB-YA+1+BASEL) MAX 0;
         BUF[4]←0;
         ARRYOUT(CHAN,BUF[0],'200);
         WORDOUT(CHAN,
          (((XB-XA+1) MAX 19) LSH 27) LOR (CODE LSH 18) LOR NW*(YB-YA+1)+2);
         WORDOUT(CHAN,(LKERN LSH 27) LOR (YB-YA+1));
         ARRCLR(LIN);
         FOR I←YA STEP 1 UNTIL YB DO
            BEGIN
            DDPAK(I,LIN[0],XA,XB);
            ARRYOUT(CHAN,LIN[0],NW);
            END;
         END
      ELSE
         BEGIN  comment add the character, or substitute it, to the file;
         INTEGER TCP; comment The character position;
         INTEGER BASOFSET; comment change in baseline;
         INTEGER ARRAY SIZ[0:'177];
         ARRYIN(ICHAN,BUF[0],'200);
         ARRCLR(SIZ);  TCP←'400;
         comment  calculate starting position for all characters;
         MAXTOP←'777; MAXBOT←0;
         FOR I←0 STEP 1 UNTIL '177 DO
         IF I≠CODE ∧ BUF[I]≠0 THEN
            BEGIN
            INTEGER BN,WN;
            BN←BUF[I] LAND '777777;
            WN←BN LAND '177;
            BN←BN % '200;
            USETI(ICHAN,BN+1);
            FOR J←1 STEP 1 UNTIL WN+1 DO K←WORDIN(ICHAN);
            SIZ[I]←(BUF[I] LAND '777777000000) LOR TCP;
            TCP←TCP + (K LAND '777777);   comment add size for this character;
            K←WORDIN(ICHAN);
	    MAXTOP←MAXTOP MIN ((K LSH -18) LAND '777);  comment get rows from top;
            MAXBOT←MAXBOT MAX (((K LSH -18) LAND '777)+(K LAND '777777));
   					 comment and rows from top to bottom;
            END
         ELSE IF I=CODE THEN
            BEGIN
            SIZ[I]←((XB-XA+1-LKERN-RKERN) LSH 18) LOR TCP;
            TCP←TCP+NW*(YB-YA+1)+2;
            END;
         ARRYOUT(CHAN,SIZ[0],'200);
         USETI(ICHAN,2);
         ARRYIN(ICHAN,SIZ[0],'200);

         MAXTOP←SIZ[3]-MAXTOP; MAXBOT←MAXBOT-SIZ[3];
         MAXBOT←MAXBOT MAX (-BASEL) MAX 0;
         MAXTOP←MAXTOP MAX (YB-YA+1+(BASEL MAX 0));

         SIZ[1]←MAXTOP+MAXBOT;
         SIZ[2]←(XB-XA+1) MAX SIZ[2];
         BASOFSET←SIZ[3];
         SIZ[3]←MAXTOP;
         BASOFSET←(SIZ[3]-BASOFSET);  comment how much baseline has moved;
         ARRYOUT(CHAN,SIZ[0],'200);
         FOR I←0 STEP 1 UNTIL '177 DO
         IF I≠CODE ∧ BUF[I]≠0 THEN
            BEGIN
            INTEGER BN,WN;
            BN←BUF[I] LAND '777777;
            WN←BN LAND '177;
            BN←BN % '200;
            USETI(ICHAN,BN+1);
            FOR J←1 STEP 1 UNTIL WN+1 DO K←WORDIN(ICHAN);
            L←(K LAND '777777);  WORDOUT(CHAN,K);
            K←WORDIN(ICHAN);
            K←(K LAND '777000777777) LOR
             ((((((K LSH -18) LAND '777) + BASOFSET) MIN 511) MAX 0) LSH 18);
            WORDOUT(CHAN,K);
            FOR J←1 STEP 1 UNTIL L-2 DO WORDOUT(CHAN,WORDIN(ICHAN));
            END
         ELSE IF I=CODE THEN
            BEGIN
            WORDOUT(CHAN,
            (((XB-XA+1) MAX 19) LSH 27) LOR (CODE LSH 18) LOR NW*(YB-YA+1)+2);
            WORDOUT(CHAN,(LKERN LSH 27) LOR
                         ((((SIZ[3]-(YB-YA+1)-BASEL) MIN 511) MAX 0) LSH 18) LOR
                         (YB-YA+1));
            ARRCLR(LIN);
            FOR J←YA STEP 1 UNTIL YB DO
               BEGIN
               DDPAK(J,LIN[0],XA,XB);
               ARRYOUT(CHAN,LIN[0],NW);
               END;
            END;
         END;
      END;
   IF ¬IFLAG THEN RELEASE(ICHAN);
   CLOSE(CHAN);
   RELEASE(CHAN);
   RETURN(¬FLAG);
   END;
INTERNAL BOOLEAN PROCEDURE XGPQUE(INTEGER SIZE);
   BEGIN
   INTEGER I;
   INTEGER ARRAY MESSAGE[1:32], HD[1:2];
   PUTDDF("DSK:TMP.TMP[TMP,HPM]");

   comment CREATE XGPQUE JOB;
   I←EXSWAP("DSK:XGPQUE.DMP[1,3]");
   IF I=0 THEN BEGIN PRINT("no job slots for XGPQUE"&'15&'12); RETURN(FALSE); END;

   comment TELL WHAT SIZE;
   MESSAGE[1]←CALL(0,"PJOB");
   MESSAGE[2]←SIZE;
   HD[1]←I;  HD[2]←LOCATION(MESSAGE[1]);
   WHILE CALL(I,"GETNAM")≠CVSIX("READY!") DO CALL(0,"SLEEP");
   I←0;  START_CODE MAIL 0,ACCESS(HD[1]); comment SEND; SETOM I; END;
   IF I≠0 THEN
      BEGIN
      PRINT("couldn't send message to XGPQUE"&'15&'12);
      RETURN(FALSE);
      END;

   RETURN(TRUE);
   END;

END;